gapminder example

Let’s recreate Hans Rosling’s famous visualization. If you have never seen it, check out this long video: https://www.ted.com/talks/hans_rosling_the_best_stats_you_ve_ever_seen?utm_campaign=tedspread&utm_medium=referral&utm_source=tedcomshare

However, for the sake of brevity, watch this video now:

Install gapminder package for this example.

install.packages(‘gapminder’)

Get the data from gapminder

data(gapminder, package = "gapminder")

Next, let’s create a static ggplot2 visualization. Note that frame and ids are the aesthetics that we have never used before. This is because they don’t belong to ggplot2. They come from plotly. So, ggplot2 will simply ignore them.

Usually we map a time variable to frame and cross-sectional id variable to ids.

gg <- ggplot(gapminder, 
             aes(x = gdpPercap, y = lifeExp, color = continent)) +
  geom_point(aes(size = pop, frame = year, ids = country)) +
  scale_x_log10() +
  labs(x = 'GDP per Capital',
       y = 'Life Expectancy',
       color = 'Continent') +
  scale_color_manual(values = wesanderson::wes_palette("Moonrise3")) +
  theme_minimal() 
Warning: Ignoring unknown aesthetics: frame, ids

Now is the time for some plotly magic!

ggplotly(gg)

Using plotly’s own functionality

Above, we used ggplot2 to build the graphics and then just modified it using plotly. However, plotly is a powerful library with tons of functionality of its own. Check out this documentation - https://plotly.com/r/getting-started/

Let’s create a base plot:

base <- gapminder %>%
  plot_ly(x = ~ gdpPercap,
          y = ~ lifeExp,
          size = ~ pop,
          color = ~ continent,
          text = ~ country,
          hoverinfo = "text") %>%
  layout(xaxis = list(type = "log"))

Next, modify the base plot and display it:

base %>%
  add_markers(frame = ~ year,
              ids = ~ country) %>%
  animation_opts(1000, 
                 easing = "elastic", 
                 redraw = FALSE
                 ) %>%
  animation_button( x = 1,
                    xanchor = "right",
                    y = 0,
                    yanchor = "bottom"
                    ) %>%
  animation_slider(currentvalue = list(prefix = "Year: ",
                                       font = list(color = "red")
                                       )
                   )
NA

Cumulative animation

We will now create a progressing time series of Amazon Inc market value. You can call it a worm plot!

Read Amazon’s monthly stock returns

Please download this file from here: https://github.com/ashgreat/DA6233

And save it in a subdirectory “Data” in your project folder.

amzn <- read_csv(here::here('Data', 'amzn_2005_2020.csv')) %>% 
  mutate(mktval = PRC*SHROUT*1000,
         date2 = as.Date(as.character(date), format = '%Y%m%d')) %>% 
  filter(!is.na(mktval)) %>% 
  mutate(id = row_number())

── Column specification ─────────────────────────────────────────────────────────────────────────────
cols(
  .default = col_double(),
  NCUSIP = col_character(),
  TICKER = col_character(),
  COMNAM = col_character(),
  SHRCLS = col_logical(),
  TSYMBOL = col_character(),
  PRIMEXCH = col_character(),
  TRDSTAT = col_character(),
  SECSTAT = col_character(),
  CUSIP = col_character(),
  DCLRDT = col_logical(),
  DLPDT = col_logical(),
  NEXTDT = col_logical(),
  PAYDT = col_logical(),
  RCRDDT = col_logical(),
  HSICMG = col_logical(),
  HSICIG = col_logical(),
  DISTCD = col_logical(),
  DIVAMT = col_logical(),
  FACPR = col_logical(),
  FACSHR = col_logical()
  # ... with 5 more columns
)
ℹ Use `spec()` for the full column specifications.
head(amzn)
NA

In order to create a worm, plotly needs to create multiple data sets capturing the progress. First data set will effectively have only one observation for the first month. The second data set will have 2 observations, and so on. These are all stacked on top of each other to get a large data set.

accumulate_by <- function(dat, var) {
  var <- lazyeval::f_eval(var, dat)
  lvls <- plotly:::getLevels(var)
  dats <- lapply(seq_along(lvls), function(x) {
    cbind(dat[var %in% lvls[seq(1, x)], ], frame = lvls[[x]])
  })
  dplyr::bind_rows(dats)
}

amzn2 <- amzn %>% accumulate_by(~id)
head(amzn2)
NA

Finally, the worm plot!

p <- amzn2 %>%
  plot_ly(
    x = ~ id, 
    y = ~ mktval,
    frame = ~frame, 
    type = 'scatter',
    mode = 'lines'
  ) %>% 
  layout(
    xaxis = list(
      title = "Date",
      zeroline = F
    ),
    yaxis = list(
      title = "Market Value",
      zeroline = F
    )
  ) %>%
  animation_opts(
    frame = 10,
    transition = 0,
    redraw = FALSE
  ) %>%
  animation_slider(
    hide = T
  ) %>%
  animation_button(
    x = 1,
    xanchor = "right",
    y = 0,
    yanchor = "bottom"
  )

p
LS0tCnRpdGxlOiAiUiBOb3RlYm9vayIKb3V0cHV0OiBodG1sX25vdGVib29rCmVkaXRvcl9vcHRpb25zOiAKICBjaHVua19vdXRwdXRfdHlwZTogaW5saW5lCi0tLQoKIyMgZ2FwbWluZGVyIGV4YW1wbGUKCkxldCdzIHJlY3JlYXRlIEhhbnMgUm9zbGluZydzIGZhbW91cyB2aXN1YWxpemF0aW9uLiBJZiB5b3UgaGF2ZSBuZXZlciBzZWVuIGl0LCBjaGVjayBvdXQgdGhpcyBsb25nIHZpZGVvOiA8aHR0cHM6Ly93d3cudGVkLmNvbS90YWxrcy9oYW5zX3Jvc2xpbmdfdGhlX2Jlc3Rfc3RhdHNfeW91X3ZlX2V2ZXJfc2Vlbj91dG1fY2FtcGFpZ249dGVkc3ByZWFkJnV0bV9tZWRpdW09cmVmZXJyYWwmdXRtX3NvdXJjZT10ZWRjb21zaGFyZT4KCkhvd2V2ZXIsIGZvciB0aGUgc2FrZSBvZiBicmV2aXR5LCB3YXRjaCB0aGlzIHZpZGVvIG5vdzoKCjxpZnJhbWUgd2lkdGg9IjU2MCIgaGVpZ2h0PSIzMTUiIHNyYz0iaHR0cHM6Ly93d3cueW91dHViZS5jb20vZW1iZWQvWjh0NGswUThlOFkiIGZyYW1lYm9yZGVyPSIwIiBhbGxvdz0iYWNjZWxlcm9tZXRlcjsgYXV0b3BsYXk7IGNsaXBib2FyZC13cml0ZTsgZW5jcnlwdGVkLW1lZGlhOyBneXJvc2NvcGU7IHBpY3R1cmUtaW4tcGljdHVyZSIgYWxsb3dmdWxsc2NyZWVuPgoKPC9pZnJhbWU+CgpJbnN0YWxsIGBnYXBtaW5kZXJgIHBhY2thZ2UgZm9yIHRoaXMgZXhhbXBsZS4KCmluc3RhbGwucGFja2FnZXMoJ2dhcG1pbmRlcicpCgpgYGB7ciBzZXR1cCwgaW5jbHVkZT1GQUxTRX0KCnBhY21hbjo6cF9sb2FkKHBsb3RseSwgdGlkeXZlcnNlLCBnYXBtaW5kZXIsIGhlcmUpCgpgYGAKCkdldCB0aGUgZGF0YSBmcm9tIGBnYXBtaW5kZXJgCgpgYGB7cn0KZGF0YShnYXBtaW5kZXIsIHBhY2thZ2UgPSAiZ2FwbWluZGVyIikKYGBgCgpOZXh0LCBsZXQncyBjcmVhdGUgYSBzdGF0aWMgYGdncGxvdDJgIHZpc3VhbGl6YXRpb24uIE5vdGUgdGhhdCBgZnJhbWVgIGFuZCBgaWRzYCBhcmUgdGhlIGFlc3RoZXRpY3MgdGhhdCB3ZSBoYXZlIG5ldmVyIHVzZWQgYmVmb3JlLiBUaGlzIGlzIGJlY2F1c2UgdGhleSBkb24ndCBiZWxvbmcgdG8gYGdncGxvdDJgLiBUaGV5IGNvbWUgZnJvbSBgcGxvdGx5YC4gU28sIGBnZ3Bsb3QyYCB3aWxsIHNpbXBseSBpZ25vcmUgdGhlbS4KClVzdWFsbHkgd2UgbWFwIGEgdGltZSB2YXJpYWJsZSB0byBgZnJhbWVgIGFuZCBjcm9zcy1zZWN0aW9uYWwgaWQgdmFyaWFibGUgdG8gYGlkc2AuCgpgYGB7cn0KZ2cgPC0gZ2dwbG90KGdhcG1pbmRlciwgCiAgICAgICAgICAgICBhZXMoeCA9IGdkcFBlcmNhcCwgeSA9IGxpZmVFeHAsIGNvbG9yID0gY29udGluZW50KSkgKwogIGdlb21fcG9pbnQoYWVzKHNpemUgPSBwb3AsIGZyYW1lID0geWVhciwgaWRzID0gY291bnRyeSkpICsKICBzY2FsZV94X2xvZzEwKCkgKwogIGxhYnMoeCA9ICdHRFAgcGVyIENhcGl0YWwnLAogICAgICAgeSA9ICdMaWZlIEV4cGVjdGFuY3knLAogICAgICAgY29sb3IgPSAnQ29udGluZW50JykgKwogIHNjYWxlX2NvbG9yX21hbnVhbCh2YWx1ZXMgPSB3ZXNhbmRlcnNvbjo6d2VzX3BhbGV0dGUoIk1vb25yaXNlMyIpKSArCiAgdGhlbWVfbWluaW1hbCgpIApgYGAKCk5vdyBpcyB0aGUgdGltZSBmb3Igc29tZSBgcGxvdGx5YCBtYWdpYyEKCmBgYHtyfQpnZ3Bsb3RseShnZykKYGBgCgojIyBVc2luZyBgcGxvdGx5YCdzIG93biBmdW5jdGlvbmFsaXR5CgpBYm92ZSwgd2UgdXNlZCBgZ2dwbG90MmAgdG8gYnVpbGQgdGhlIGdyYXBoaWNzIGFuZCB0aGVuIGp1c3QgbW9kaWZpZWQgaXQgdXNpbmcgYHBsb3RseWAuIEhvd2V2ZXIsIGBwbG90bHlgIGlzIGEgcG93ZXJmdWwgbGlicmFyeSB3aXRoIHRvbnMgb2YgZnVuY3Rpb25hbGl0eSBvZiBpdHMgb3duLiBDaGVjayBvdXQgdGhpcyBkb2N1bWVudGF0aW9uIC0gPGh0dHBzOi8vcGxvdGx5LmNvbS9yL2dldHRpbmctc3RhcnRlZC8+CgpMZXQncyBjcmVhdGUgYSBiYXNlIHBsb3Q6CgpgYGB7cn0KYmFzZSA8LSBnYXBtaW5kZXIgJT4lCiAgcGxvdF9seSh4ID0gfiBnZHBQZXJjYXAsCiAgICAgICAgICB5ID0gfiBsaWZlRXhwLAogICAgICAgICAgc2l6ZSA9IH4gcG9wLAogICAgICAgICAgY29sb3IgPSB+IGNvbnRpbmVudCwKICAgICAgICAgIHRleHQgPSB+IGNvdW50cnksCiAgICAgICAgICBob3ZlcmluZm8gPSAidGV4dCIpICU+JQogIGxheW91dCh4YXhpcyA9IGxpc3QodHlwZSA9ICJsb2ciKSkKYGBgCgpOZXh0LCBtb2RpZnkgdGhlIGJhc2UgcGxvdCBhbmQgZGlzcGxheSBpdDoKCmBgYHtyIG1lc3NhZ2U9RkFMU0UsIHdhcm5pbmc9RkFMU0V9CmJhc2UgJT4lCiAgYWRkX21hcmtlcnMoZnJhbWUgPSB+IHllYXIsCiAgICAgICAgICAgICAgaWRzID0gfiBjb3VudHJ5KSAlPiUKICBhbmltYXRpb25fb3B0cygxMDAwLCAKICAgICAgICAgICAgICAgICBlYXNpbmcgPSAiZWxhc3RpYyIsIAogICAgICAgICAgICAgICAgIHJlZHJhdyA9IEZBTFNFCiAgICAgICAgICAgICAgICAgKSAlPiUKICBhbmltYXRpb25fYnV0dG9uKCB4ID0gMSwKICAgICAgICAgICAgICAgICAgICB4YW5jaG9yID0gInJpZ2h0IiwKICAgICAgICAgICAgICAgICAgICB5ID0gMCwKICAgICAgICAgICAgICAgICAgICB5YW5jaG9yID0gImJvdHRvbSIKICAgICAgICAgICAgICAgICAgICApICU+JQogIGFuaW1hdGlvbl9zbGlkZXIoY3VycmVudHZhbHVlID0gbGlzdChwcmVmaXggPSAiWWVhcjogIiwKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgZm9udCA9IGxpc3QoY29sb3IgPSAicmVkIikKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgKQogICAgICAgICAgICAgICAgICAgKQoKYGBgCgojIyBDdW11bGF0aXZlIGFuaW1hdGlvbgoKV2Ugd2lsbCBub3cgY3JlYXRlIGEgcHJvZ3Jlc3NpbmcgdGltZSBzZXJpZXMgb2YgQW1hem9uIEluYyBtYXJrZXQgdmFsdWUuIFlvdSBjYW4gY2FsbCBpdCBhIHdvcm0gcGxvdCEKClJlYWQgQW1hem9uJ3MgbW9udGhseSBzdG9jayByZXR1cm5zCgpQbGVhc2UgZG93bmxvYWQgdGhpcyBmaWxlIGZyb20gaGVyZTogPGh0dHBzOi8vZ2l0aHViLmNvbS9hc2hncmVhdC9EQTYyMzM+CgpBbmQgc2F2ZSBpdCBpbiBhIHN1YmRpcmVjdG9yeSAiRGF0YSIgaW4geW91ciBwcm9qZWN0IGZvbGRlci4KCmBgYHtyfQphbXpuIDwtIHJlYWRfY3N2KGhlcmU6OmhlcmUoJ0RhdGEnLCAnYW16bl8yMDA1XzIwMjAuY3N2JykpICU+JSAKICBtdXRhdGUobWt0dmFsID0gUFJDKlNIUk9VVCoxMDAwLAogICAgICAgICBkYXRlMiA9IGFzLkRhdGUoYXMuY2hhcmFjdGVyKGRhdGUpLCBmb3JtYXQgPSAnJVklbSVkJykpICU+JSAKICBmaWx0ZXIoIWlzLm5hKG1rdHZhbCkpICU+JSAKICBtdXRhdGUoaWQgPSByb3dfbnVtYmVyKCkpCgpoZWFkKGFtem4pCgpgYGAKCkluIG9yZGVyIHRvIGNyZWF0ZSBhIHdvcm0sIGBwbG90bHlgIG5lZWRzIHRvIGNyZWF0ZSBtdWx0aXBsZSBkYXRhIHNldHMgY2FwdHVyaW5nIHRoZSBwcm9ncmVzcy4gRmlyc3QgZGF0YSBzZXQgd2lsbCBlZmZlY3RpdmVseSBoYXZlIG9ubHkgb25lIG9ic2VydmF0aW9uIGZvciB0aGUgZmlyc3QgbW9udGguIFRoZSBzZWNvbmQgZGF0YSBzZXQgd2lsbCBoYXZlIDIgb2JzZXJ2YXRpb25zLCBhbmQgc28gb24uIFRoZXNlIGFyZSBhbGwgc3RhY2tlZCBvbiB0b3Agb2YgZWFjaCBvdGhlciB0byBnZXQgYSBsYXJnZSBkYXRhIHNldC4KCmBgYHtyfQphY2N1bXVsYXRlX2J5IDwtIGZ1bmN0aW9uKGRhdCwgdmFyKSB7CiAgdmFyIDwtIGxhenlldmFsOjpmX2V2YWwodmFyLCBkYXQpCiAgbHZscyA8LSBwbG90bHk6OjpnZXRMZXZlbHModmFyKQogIGRhdHMgPC0gbGFwcGx5KHNlcV9hbG9uZyhsdmxzKSwgZnVuY3Rpb24oeCkgewogICAgY2JpbmQoZGF0W3ZhciAlaW4lIGx2bHNbc2VxKDEsIHgpXSwgXSwgZnJhbWUgPSBsdmxzW1t4XV0pCiAgfSkKICBkcGx5cjo6YmluZF9yb3dzKGRhdHMpCn0KCmFtem4yIDwtIGFtem4gJT4lIGFjY3VtdWxhdGVfYnkofmlkKQpoZWFkKGFtem4yKQoKYGBgCgpGaW5hbGx5LCB0aGUgd29ybSBwbG90IQoKYGBge3J9CnAgPC0gYW16bjIgJT4lCiAgcGxvdF9seSgKICAgIHggPSB+IGlkLCAKICAgIHkgPSB+IG1rdHZhbCwKICAgIGZyYW1lID0gfmZyYW1lLCAKICAgIHR5cGUgPSAnc2NhdHRlcicsCiAgICBtb2RlID0gJ2xpbmVzJwogICkgJT4lIAogIGxheW91dCgKICAgIHhheGlzID0gbGlzdCgKICAgICAgdGl0bGUgPSAiRGF0ZSIsCiAgICAgIHplcm9saW5lID0gRgogICAgKSwKICAgIHlheGlzID0gbGlzdCgKICAgICAgdGl0bGUgPSAiTWFya2V0IFZhbHVlIiwKICAgICAgemVyb2xpbmUgPSBGCiAgICApCiAgKSAlPiUKICBhbmltYXRpb25fb3B0cygKICAgIGZyYW1lID0gMTAsCiAgICB0cmFuc2l0aW9uID0gMCwKICAgIHJlZHJhdyA9IEZBTFNFCiAgKSAlPiUKICBhbmltYXRpb25fc2xpZGVyKAogICAgaGlkZSA9IFQKICApICU+JQogIGFuaW1hdGlvbl9idXR0b24oCiAgICB4ID0gMSwKICAgIHhhbmNob3IgPSAicmlnaHQiLAogICAgeSA9IDAsCiAgICB5YW5jaG9yID0gImJvdHRvbSIKICApCgpwCmBgYAo=